home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / hyperbole / hui.el < prev    next >
Encoding:
Text File  |  1995-08-26  |  32.2 KB  |  918 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         hui.el
  4. ;; SUMMARY:      GNU Emacs User Interface to Hyperbole
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     hypermedia
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Brown U.
  10. ;;
  11. ;; ORIG-DATE:    19-Sep-91 at 21:42:03
  12. ;; LAST-MOD:     25-Aug-95 at 02:26:56 by Bob Weiner
  13. ;;
  14. ;; This file is part of Hyperbole.
  15. ;; Available for use and distribution under the same terms as GNU Emacs.
  16. ;;
  17. ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
  18. ;; Developed with support from Motorola Inc.
  19. ;;
  20. ;; DESCRIPTION:  
  21. ;; DESCRIP-END.
  22.  
  23. ;;; ************************************************************************
  24. ;;; Other required Elisp libraries
  25. ;;; ************************************************************************
  26.  
  27. (require 'hargs) (require 'set) (require 'hmail)
  28.  
  29. ;;; ************************************************************************
  30. ;;; Public variables
  31. ;;; ************************************************************************
  32.  
  33. (defvar hui:ebut-delete-confirm-p t
  34.   "*Non-nil means prompt before interactively deleting explicit buttons.")
  35.  
  36. ;;; ************************************************************************
  37. ;;; Public functions
  38. ;;; ************************************************************************
  39.  
  40. (defun hui:ebut-create (&optional start end)
  41.   "Creates an explicit but starting from label between optional START and END.
  42. Indicates by delimiting and adding any necessary instance number of the button
  43. label."
  44.   (interactive (list (and (marker-position (hypb:mark-marker t))
  45.               (region-beginning))
  46.              (and (marker-position (hypb:mark-marker t))
  47.               (region-end))))
  48.   (let ((default-lbl) lbl but-buf actype)
  49.     (save-excursion
  50.       (setq default-lbl
  51.         (hui:hbut-label-default start end (not (interactive-p)))
  52.         lbl (hui:hbut-label default-lbl "ebut-create"))
  53.       (if (not (equal lbl default-lbl)) (setq default-lbl nil))
  54.       
  55.       (setq but-buf (if default-lbl (current-buffer) (hui:ebut-buf)))
  56.       (hui:buf-writable-err but-buf "ebut-create")
  57.       
  58.       (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
  59.       (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
  60.       (setq actype (hui:actype))
  61.       (hattr:set 'hbut:current 'actype actype)
  62.       (hattr:set 'hbut:current 'args (hargs:actype-get actype))
  63.       (hattr:set 'hbut:current 'action
  64.          (and (boundp 'hui:ebut-prompt-for-action)
  65.               hui:ebut-prompt-for-action (hui:action actype)))
  66.       )
  67.     (ebut:operate lbl nil)))
  68.  
  69. (defun hui:ebut-delete (but-key &optional key-src)
  70.   "Deletes explicit Hyperbole button given by BUT-KEY in optional KEY-SRC.
  71. KEY-SRC may be a buffer or a pathname, when nil the current buffer is used.
  72. Returns t if button is deleted, nil if user chooses not to delete or signals
  73. an error otherwise.  If called interactively, prompts user whether to delete
  74. and derives BUT-KEY from the button that point is within.
  75. Signals an error if point is not within a button."
  76.   (interactive (list (if (ebut:at-p)
  77.              (hattr:get 'hbut:current 'lbl-key)
  78.                nil)))
  79.   (cond ((null but-key)
  80.      (hypb:error
  81.       "(ebut-delete): Point is not over the label of an existing button."))
  82.     ((not (stringp but-key))
  83.      (hypb:error
  84.       "(ebut-delete): Invalid label key argument: '%s'." but-key)))
  85.   (let ((interactive (interactive-p)))
  86.     (if (and hui:ebut-delete-confirm-p interactive)
  87.     (if (y-or-n-p (format "Delete button %s%s%s? "
  88.                   ebut:start
  89.                   (hbut:key-to-label but-key) ebut:end))
  90.         (hui:ebut-delete-op interactive but-key key-src)
  91.       (message ""))
  92.       (hui:ebut-delete-op interactive but-key key-src))))
  93.       
  94. (defun hui:ebut-edit ()
  95.   "Creates or modifies an explicit Hyperbole button when conditions are met.
  96. A region must have been delimited with the action-key and point must now be
  97. within it before this function is called or it will do nothing.  The region
  98. must be no larger than the size given by 'ebut:max-len'.  It must be entirely
  99. within or entirely outside of an existing explicit button.  When region is
  100. within the button, the button is interactively modified.  Otherwise, a new
  101. button is created interactively with the region as the default label."
  102.   (interactive)
  103.   (let ((m (marker-position (hypb:mark-marker t)))
  104.     (op action-key-depress-prev-point) (p (point)) (lbl-key))
  105.     (if (and m (eq (marker-buffer m) (marker-buffer op))
  106.          (< op m) (<= (- m op) ebut:max-len)
  107.          (<= p m) (<= op p))
  108.     (progn
  109.       (if (setq lbl-key (ebut:label-p))
  110.           (hui:ebut-modify lbl-key)
  111.         (hui:ebut-create op m))
  112.       t))))
  113.  
  114. (defun hui:ebut-modify (lbl-key)
  115.   "Modifies an explicit Hyperbole button given by LBL-KEY.
  116. Signals an error when no such button is found in the current buffer."
  117.   (interactive (list (save-excursion
  118.                (hui:buf-writable-err (current-buffer) "ebut-modify")
  119.                (or (ebut:label-p)
  120.                (ebut:label-to-key
  121.                 (hargs:read-match "Button to modify: "
  122.                           (ebut:alist) nil t
  123.                           nil 'ebut))))))
  124.   (let ((lbl (ebut:key-to-label lbl-key))
  125.     (but-buf (current-buffer))
  126.     actype but new-lbl)
  127.     (save-excursion
  128.       (or (interactive-p)
  129.       (hui:buf-writable-err but-buf "ebut-modify"))
  130.       
  131.       (or (setq but (ebut:get lbl-key but-buf))
  132.       (progn (pop-to-buffer but-buf)
  133.          (hypb:error "(ebut-modify): Invalid button, no data for '%s'." lbl)))
  134.       
  135.       (setq new-lbl
  136.         (hargs:read
  137.          "Change button label to: "
  138.          (function
  139.            (lambda (lbl)
  140.         (and (not (string= lbl "")) (<= (length lbl) ebut:max-len))))
  141.          lbl
  142.          (format "(ebut-modify): Enter a string of at most %s chars."
  143.              ebut:max-len)
  144.          'string))
  145.       
  146.       (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
  147.       (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
  148.       (setq actype (hui:actype (hattr:get but 'actype)))
  149.       (hattr:set 'hbut:current 'actype actype)
  150.       (hattr:set 'hbut:current 'args (hargs:actype-get actype 'modifying))
  151.       (hattr:set 'hbut:current 'action
  152.          (and (boundp 'hui:ebut-prompt-for-action)
  153.               hui:ebut-prompt-for-action (hui:action actype)))
  154.       )
  155.     (ebut:operate lbl new-lbl)))
  156.  
  157. (defun hui:ebut-rename (curr-label new-label)
  158.   "Renames explicit Hyperbole button given by CURR-LABEL to NEW-LABEL.
  159. If called interactively when point is not within an explicit button:
  160.    prompts for old and new button label values and performs rename.
  161. If called interactively when point is within an explicit button:
  162.    saves button label and tells user to edit label, then call again.
  163.    second call changes the button's name from the stored value to the
  164.    edited value.
  165. Signals an error if any problem occurs."
  166.   (interactive
  167.    (save-excursion
  168.      (let (curr-label new-label)
  169.        (hui:buf-writable-err (current-buffer) "ebut-rename")
  170.        (if hui:ebut-label-prev
  171.        (setq curr-label hui:ebut-label-prev
  172.          new-label (ebut:label-p 'as-label))
  173.      (setq new-label nil
  174.            curr-label 
  175.            (or (ebut:label-p 'as-label)
  176.            (let ((buts (ebut:alist)))
  177.              (if (null buts)
  178.              (hypb:error "(ebut-rename): No explicit buttons in buffer.")
  179.                (prog1 (hargs:read-match
  180.                    "Button label to rename: "
  181.                    buts nil t nil 'ebut)
  182.              (setq new-label
  183.                    (hargs:read
  184.                 "Rename button label to: "
  185.                 (function
  186.                   (lambda (lbl)
  187.                    (and (not (string= lbl ""))
  188.                     (<= (length lbl) ebut:max-len))))
  189.                 curr-label
  190.                 (format
  191.                  "(ebut-rename): Use a quoted string of at most %s chars."
  192.                  ebut:max-len)
  193.                 'string))))))))
  194.        (list curr-label new-label))))
  195.  
  196.   (save-excursion
  197.     (if (interactive-p)
  198.     nil
  199.       (hui:buf-writable-err (current-buffer) "ebut-rename")
  200.       (if (or (not (stringp curr-label)) (string= curr-label ""))
  201.       (hypb:error "(ebut-rename): 'curr-label' must be a non-empty string: %s"
  202.          curr-label))
  203.       (and (stringp new-label) (string= new-label "")
  204.        (hypb:error "(ebut-rename): 'new-label' must be a non-empty string: %s"
  205.           new-label)))
  206.     (or (ebut:get (ebut:label-to-key curr-label))
  207.     (hypb:error "(ebut-rename): Can't rename %s since no button data."
  208.            curr-label))
  209.     )
  210.   (cond (new-label
  211.      (ebut:operate curr-label new-label)
  212.      (setq hui:ebut-label-prev nil)
  213.      (message "Renamed from '%s' to '%s'." curr-label new-label))
  214.     (curr-label
  215.      (setq hui:ebut-label-prev curr-label)
  216.      (message "Edit button label and use same command to finish rename."))
  217.     (t (hypb:error "(ebut-rename): Move point to within a button label."))))
  218.  
  219. (defun hui:ebut-search (string &optional match-part)
  220.   "Shows lines of files/buffers containing an explicit but match for STRING.
  221. Returns number of buttons matched and displayed.
  222. By default, only matches for whole button labels are found, optional MATCH-PART
  223. enables partial matches.  The match lines are shown in a buffer which serves as
  224. a menu to find any of the occurrences."
  225.   (interactive (list (read-string "Search for button string: ")
  226.              (y-or-n-p "Enable partial matches? ")))
  227.   (if (not (stringp string))
  228.       (hypb:error "(ebut-search): String to search for is required."))
  229.   (let*  ((prefix (if (> (length string) 14)
  230.               (substring string 0 13) string))
  231.       (out-buf (get-buffer-create (concat "*" prefix " Hypb Search*")))
  232.       (total (ebut:search string out-buf match-part)))
  233.     (if (> total 0)
  234.     (progn
  235.       (set-buffer out-buf)
  236.       (moccur-mode)
  237.       (if (fboundp 'outline-minor-mode)
  238.           (and (progn (goto-char 1)
  239.               (search-forward "\C-m" nil t))
  240.            (outline-minor-mode 1)))
  241.       (if (fboundp 'hproperty:but-create)
  242.           (hproperty:but-create nil nil (regexp-quote
  243.                       (if match-part string
  244.                     (concat ebut:start string ebut:end)))))
  245.       (goto-char (point-min))
  246.       (pop-to-buffer out-buf)
  247.       (if (interactive-p) (message "%d match%s." total
  248.                        (if (> total 1) "es" ""))
  249.         total))
  250.       (if (interactive-p) (message "No matches.")
  251.     total))))
  252.  
  253. (defun hui:error (&rest args)
  254.   (hypb:error "(hui:error): Obsolete, use hypb:error instead."))
  255.  
  256. (defun hui:gbut-create (lbl)
  257.   "Creates Hyperbole global button with LBL."
  258.   (interactive "sCreate global button labeled: ")
  259.   (let (but-buf actype)
  260.     (save-excursion
  261.       (setq actype (hui:actype))
  262.       (setq but-buf (set-buffer (find-file-noselect gbut:file)))
  263.       (hui:buf-writable-err but-buf "ebut-create")
  264.       ;; This prevents movement of point which might be useful to user.
  265.       (save-excursion
  266.     (goto-char (point-max))
  267.     (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
  268.     (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
  269.     (hattr:set 'hbut:current 'actype actype)
  270.     (hattr:set 'hbut:current 'args (hargs:actype-get actype))
  271.     (hattr:set 'hbut:current 'action
  272.            (and (boundp 'hui:ebut-prompt-for-action)
  273.             hui:ebut-prompt-for-action (hui:action actype)))
  274.     (setq lbl (concat lbl (ebut:operate lbl nil)))
  275.     (goto-char (point-max))
  276.     (insert "\n")
  277.     (save-buffer)
  278.     )
  279.       (message "%s created." lbl)
  280.       )))
  281.  
  282. (defun hui:gbut-modify (lbl-key)
  283.   "Modifies a global Hyperbole button given by LBL-KEY.
  284. Signals an error when no such button is found."
  285.   (interactive (list (save-excursion
  286.                (hui:buf-writable-err
  287.             (find-file-noselect gbut:file) "gbut-modify")
  288.                (hbut:label-to-key
  289.             (hargs:read-match "Global button to modify: "
  290.                       (mapcar 'list (gbut:lbl-list))
  291.                       nil t nil 'ebut)))))
  292.   (let ((lbl (hbut:key-to-label lbl-key))
  293.     (but-buf (find-file-noselect gbut:file))
  294.     actype but new-lbl)
  295.     (save-excursion
  296.       (or (interactive-p)
  297.       (hui:buf-writable-err but-buf "gbut-modify"))
  298.       
  299.       (or (setq but (ebut:get lbl-key but-buf))
  300.       (progn (pop-to-buffer but-buf)
  301.          (hypb:error
  302.           "(gbut-modify): Invalid button, no data for '%s'." lbl)))
  303.       
  304.       (setq new-lbl
  305.         (hargs:read
  306.          "Change global button label to: "
  307.          (function
  308.            (lambda (lbl)
  309.         (and (not (string= lbl "")) (<= (length lbl) ebut:max-len))))
  310.          lbl
  311.          (format "(gbut-modify): Enter a string of at most %s chars."
  312.              ebut:max-len)
  313.          'string))
  314.       
  315.       (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
  316.       (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
  317.       (setq actype (hui:actype (hattr:get but 'actype)))
  318.       (hattr:set 'hbut:current 'actype actype)
  319.       (hattr:set 'hbut:current 'args (hargs:actype-get actype 'modifying))
  320.       (hattr:set 'hbut:current 'action
  321.          (and (boundp 'hui:ebut-prompt-for-action)
  322.               hui:ebut-prompt-for-action (hui:action actype)))
  323.       (set-buffer but-buf)
  324.       (ebut:operate lbl new-lbl))))
  325.  
  326. (defun hui:hbut-act (&optional but)
  327.   "Executes action for optional Hyperbole button symbol BUT in current buffer.
  328. Default is the current button."
  329.   (interactive
  330.    (let ((but (hbut:at-p)) (lst))
  331.      (list
  332.       (cond (but)
  333.         ((setq lst (ebut:alist))
  334.          (ebut:get (ebut:label-to-key
  335.             (hargs:read-match "Button to execute: " lst nil t
  336.                       (ebut:label-p 'as-label) 'ebut))))
  337.         (t (hypb:error "(hbut-act): No explicit buttons in buffer."))))))
  338.   (cond ((and (interactive-p) (null but))
  339.      (hypb:error "(hbut-act): No current button to activate."))
  340.     ((not (hbut:is-p but))
  341.      (hypb:error "(hbut-act): Button is invalid; it has no attributes."))
  342.     (t (or but (setq but 'hbut:current))
  343.        (hui:but-flash) (hyperb:act but))))
  344.  
  345. (defun hui:hbut-help (&optional but)
  346.   "Checks for and explains an optional button given by symbol, BUT.
  347. BUT defaults to the button whose label point is within."
  348.   (interactive)
  349.   (setq but (or but (hbut:at-p)
  350.         (ebut:get (ebut:label-to-key
  351.                (hargs:read-match "Help for button: "
  352.                          (ebut:alist) nil t nil 'ebut)))))
  353.   (or but
  354.       (hypb:error "(hbut-help):  Move point to a valid Hyperbole button."))
  355.   (if (not (hbut:is-p but))
  356.       (cond (but (hypb:error "(hbut-help): Invalid button."))
  357.         (t   (hypb:error
  358.           "(hbut-help): Not on an implicit button and no buffer explicit buttons."))))
  359.   (let ((type-help-func (intern-soft
  360.              (concat 
  361.               (htype:names 'ibtypes (hattr:get but 'categ))
  362.               ":help"))))
  363.     (or (equal (hypb:indirect-function 'hui:but-flash)
  364.            (function (lambda nil)))
  365.     ;; Only flash button if point is on it.
  366.     (let ((lbl-key (hattr:get but 'lbl-key)))
  367.       (and lbl-key
  368.            (or (equal lbl-key (ebut:label-p))
  369.            (equal lbl-key (ibut:label-p)))
  370.            (hui:but-flash))))
  371.     (if type-help-func
  372.     (funcall type-help-func but)
  373.       (let ((total (hbut:report but)))
  374.     (if total (hui:help-ebut-highlight))))))
  375.  
  376. (defun hui:hbut-label (default-label func-name)
  377.   "Reads button label from user using DEFAULT-LABEL and caller's FUNC-NAME."
  378.   (hargs:read "Button label: "
  379.           (function
  380.         (lambda (lbl)
  381.           (and (not (string= lbl "")) (<= (length lbl) ebut:max-len))))
  382.           default-label
  383.           (format "(%s): Enter a string of at most %s chars."
  384.               func-name ebut:max-len)
  385.           'string))
  386.  
  387. (defun hui:hbut-label-default (start end &optional skip-len-test)
  388.   "Returns default label based on START and END region markers or points.
  389. Optional SKIP-LEN-TEST means don't limit label to 'ebut:max-len' length.
  390. Returns nil if START or END are invalid or if region fails length test. 
  391.  
  392. Also has side effect of moving point to start of default label, if any."
  393.   (if (markerp start) (setq start (marker-position start)))
  394.   (if (markerp end) (setq end (marker-position end)))
  395.   ;; Test whether to use region as default button label.
  396.   (if (and (integerp start) (integerp end) 
  397.        (or skip-len-test
  398.            (<= (max (- end start) (- start end)) ebut:max-len)))
  399.       (progn (goto-char start)
  400.          (buffer-substring start end))))
  401.  
  402. (defun hui:hbut-report (&optional arg)
  403.   "Pretty prints attributes of current button, using optional prefix ARG.
  404. See 'hbut:report'."
  405.   (interactive "P")
  406.   (if (and arg (symbolp arg))
  407.       (hui:hbut-help arg)
  408.     (let ((total (hbut:report arg)))
  409.       (if total
  410.       (progn (hui:help-ebut-highlight)
  411.          (message "%d button%s." total (if (/= total 1) "s" "")))))))
  412.  
  413. (fset 'hui:hbut-summarize 'hui:hbut-report)
  414.  
  415. (defun hui:link-directly ()
  416.   "Creates a Hyperbole link button at depress point, linked to release point.
  417. See also documentation for 'hui:link-possible-types'."
  418.   (let* ((link-types (hui:link-possible-types))
  419.      (but-window action-key-depress-window)
  420.      (num-types (length link-types))
  421.      (release-window (selected-window))
  422.      (but-modify nil)
  423.      type-and-args lbl-key but-loc but-dir)
  424.     (select-window action-key-depress-window)
  425.     (hui:buf-writable-err (current-buffer) "link-directly")
  426.     (if (ebut:at-p)
  427.     (progn
  428.       (setq but-modify t
  429.         but-loc (hattr:get 'hbut:current 'loc)
  430.         but-dir (hattr:get 'hbut:current 'dir)
  431.         lbl-key (hattr:get 'hbut:current 'lbl-key)))
  432.       (setq but-loc (hui:key-src (current-buffer))
  433.         but-dir (hui:key-dir (current-buffer))
  434.         lbl-key (hbut:label-to-key
  435.               (hui:hbut-label
  436.             (if (marker-position (hypb:mark-marker t))
  437.                 (hui:hbut-label-default
  438.                   (region-beginning) (region-end)))
  439.             "link-directly"))))
  440.     (select-window release-window)
  441.  
  442.     (cond ((= num-types 0)
  443.        (error "(link-directly): No possible link type to create."))
  444.       ((= num-types 1)
  445.        (hui:link-create but-modify
  446.                 but-window lbl-key but-loc but-dir
  447.                 (setq type-and-args (car link-types))))
  448.       (t;; more than 1
  449.         (let ((item)
  450.           type)
  451.           (hui:link-create
  452.         but-modify but-window
  453.         lbl-key but-loc but-dir
  454.         (setq type-and-args
  455.               (hui:menu-select
  456.             (cons '("Link to>")
  457.                   (mapcar
  458.                 (function
  459.                   (lambda (type-and-args)
  460.                     (setq type (car type-and-args))
  461.                     (list 
  462.                       (capitalize
  463.                     (if (string-match
  464.                           "^\\(link-to\\|eval\\)-"
  465.                           (setq item (symbol-name type)))
  466.                         (setq item (substring
  467.                              item (match-end 0)))
  468.                       item))
  469.                       type-and-args
  470.                       (documentation
  471.                        (intern (concat "actypes::"
  472.                                (symbol-name type)))))))
  473.                 link-types))))))))
  474.     (message "`%s' button %s type `%s'."
  475.          (hbut:key-to-label lbl-key)
  476.          (if but-modify "set to" "created with")
  477.          (car type-and-args))))
  478.  
  479. ;;; ************************************************************************
  480. ;;; Private functions
  481. ;;; ************************************************************************
  482.  
  483. (defun hui:action (actype &optional prompt)
  484.   "Prompts for and returns an action to override action from ACTYPE."
  485.   (and actype
  486.        (let* ((act) (act-str)
  487.           (params (actype:params actype))
  488.           (params-str (and params (concat " " (prin1-to-string params))))
  489.           )
  490.      (while (progn
  491.          (while (and (setq act-str
  492.                    (hargs:read
  493.                     (or prompt (concat "Action" params-str
  494.                                ": ")) nil nil
  495.                                nil 'string))
  496.                  (not (string= act-str ""))
  497.                  (condition-case ()
  498.                  (progn (setq act (read act-str)) nil)
  499.                    (error
  500.                 (beep) (message "Invalid action syntax.")
  501.                 (sit-for 3) t))))
  502.          (and (not (symbolp act))
  503.               params
  504.               ;; Use the weak condition that action must
  505.               ;; involve at least one of actype's parameters
  506.               ;; or else we assume the action is invalid, tell
  507.               ;; the user and provide another chance for entry.
  508.               (not (memq t
  509.                  (mapcar
  510.                   (function
  511.                     (lambda (param)
  512.                      (setq param (symbol-name param))
  513.                      (and (string-match
  514.                        (concat "[\( \t\n,']"
  515.                            (regexp-quote param)
  516.                            "[\(\) \t\n\"]")
  517.                        act-str)
  518.                       t)))
  519.                   params)))
  520.               ))
  521.        (beep) (message "Action must use at least one parameter.")
  522.        (sit-for 3))
  523.      (let (head)
  524.        (while (cond ((listp act)
  525.              (and act (setq head (car act))
  526.                   (not (or (eq head 'lambda)
  527.                        (eq head 'defun)
  528.                        (eq head 'defmacro)))
  529.                   (setq act (list 'lambda params act))
  530.                   nil  ;; terminate loop
  531.                   ))
  532.             ((symbolp act)
  533.              (setq act (cons act params)))
  534.             ((stringp act)
  535.              (setq act (action:kbd-macro act 1)))
  536.             ;; Unrecognized form
  537.             (t (setq act nil))
  538.             )))
  539.      act)))
  540.  
  541. (defun hui:actype (&optional default-actype prompt)
  542.   "Using optional DEFAULT-ACTYPE, PROMPTs for a button action type.
  543. DEFAULT-ACTYPE may be a valid symbol or symbol-name."
  544.   (and default-actype (symbolp default-actype)
  545.        (progn
  546.      (setq default-actype (symbol-name default-actype))
  547.      (if (string-match "actypes::" default-actype)
  548.          (setq default-actype (substring default-actype (match-end 0))))))
  549.   (if (or (null default-actype) (stringp default-actype))
  550.       (intern-soft
  551.        (concat "actypes::"
  552.            (hargs:read-match (or prompt "Button's action type: ")
  553.                 (mapcar 'list (htype:names 'actypes))
  554.                 nil t default-actype 'actype)))
  555.     (hypb:error "(actype): Invalid default action type received.")
  556.     ))
  557.  
  558. (defun hui:buf-writable-err (but-buf func-name)
  559.   "If BUT-BUF is read-only or is unwritable, signal an error from FUNC-NAME."
  560.   (let ((obuf (prog1 (current-buffer) (set-buffer but-buf)))
  561.     ;; (unwritable (and buffer-file-name
  562.     ;;         (not (file-writable-p buffer-file-name))))
  563.     (err))
  564.     ;; (if unwritable
  565.     ;;     Commented error out since some people want to be able to create
  566.     ;;     buttons within files which they have purposely marked read-only.
  567.     ;;     (setq err 
  568.     ;;         (format "(ebut-modify): You are not allowed to modify '%s'."
  569.     ;;             (file-name-nondirectory buffer-file-name))))
  570.     (if buffer-read-only
  571.     (setq err
  572.           (format
  573.            "Button buffer '%s' is read-only.  Use %s to change it."
  574.            (buffer-name but-buf)
  575.            (hypb:cmd-key-string
  576.         (if (where-is-internal 'vc-toggle-read-only)
  577.             'vc-toggle-read-only 'toggle-read-only))
  578.            )))
  579.     (set-buffer obuf)
  580.     (if err (progn (pop-to-buffer but-buf) (hypb:error err)))))
  581.  
  582. (defun hui:ebut-buf (&optional prompt)
  583.   "Prompt for and return a buffer in which to place a button."
  584.   (let ((buf-name))
  585.     (while
  586.     (progn
  587.       (setq buf-name
  588.         (hargs:read-match
  589.          (or prompt "Button's buffer: ")
  590.          (delq nil
  591.                (mapcar
  592.             (function
  593.               (lambda (buf)
  594.                (let ((b (buffer-name buf)))
  595.                  (if (and (not (string-match "mail\\*" b))
  596.                       (not (string-match "\\*post-news\\*" b))
  597.                       (string-match "\\`[* ]" b))
  598.                  nil 
  599.                    (cons b nil)))))
  600.             (buffer-list)))
  601.          nil t (buffer-name) 'buffer))
  602.       (or (null buf-name) (equal buf-name "")))
  603.       (beep))
  604.   (get-buffer buf-name)))
  605.  
  606. (defun hui:ebut-delete-op (interactive but-key key-src)
  607.   "INTERACTIVEly or not deletes explicit Hyperbole button given by BUT-KEY in KEY-SRC.
  608. KEY-SRC may be a buffer or a pathname, when nil the current buffer is used.
  609. Returns t if button is deleted, signals error otherwise.  If called
  610. with INTERACTIVE non-nil, derives BUT-KEY from the button that point is
  611. within."
  612.   (let ((buf (current-buffer)) (ebut))
  613.     (if (if interactive
  614.         (ebut:delete)
  615.       (cond ((or (null key-src) (and (bufferp key-src) (setq buf key-src)))
  616.          (setq ebut (ebut:get but-key key-src)))
  617.         ((and (stringp key-src)
  618.               (setq buf (find-file-noselect key-src)))
  619.          (setq ebut (ebut:get but-key buf)))
  620.         (t (hypb:error "(ebut-delete): Invalid key-src: '%s'." key-src)))
  621.       (if ebut
  622.           (ebut:delete ebut)
  623.         (hypb:error "(ebut-delete): No valid %s button in %s."
  624.            (ebut:key-to-label but-key) buf))
  625.       )
  626.     (progn (set-buffer buf)
  627.            (if interactive
  628.            (progn
  629.              (call-interactively 'hui:ebut-unmark)
  630.              (message "Button deleted."))
  631.          (hui:ebut-unmark but-key key-src))
  632.            (if (hmail:reader-p) (hmail:msg-narrow))
  633.            )
  634.       (hypb:error "(ebut-delete): You may not delete buttons from this buffer."))))
  635.  
  636. (defun hui:ebut-delimit (start end instance-str)
  637.   (hypb:error "(hui:ebut-delimit): Obsolete, use ebut:delimit instead."))
  638.  
  639. (defun hui:ebut-operate (curr-label new-label)
  640.   (hypb:error "(hui:ebut-operate): Obsolete, use ebut:operate instead."))
  641.  
  642. (defun hui:ebut-unmark (&optional but-key key-src directory)
  643.   "Remove delimiters from button given by BUT-KEY in KEY-SRC of DIRECTORY.
  644. All args are optional, the current button and buffer file are the defaults."
  645.   (interactive)
  646.   (let ((form (function
  647.            (lambda ()
  648.          (let ((buffer-read-only) start end)
  649.            (setq start (match-beginning 0)
  650.              end (match-end 0))
  651.            (and (fboundp 'hproperty:but-delete)
  652.             (hproperty:but-delete start))
  653.            (skip-chars-backward " \t\n")
  654.            (skip-chars-backward "0-9")
  655.            (if (= (preceding-char) (string-to-char ebut:instance-sep))
  656.                (setq start (1- (point))))
  657.            (if (search-backward ebut:start (- (point) ebut:max-len) t)
  658.                (if current-prefix-arg
  659.                ;; Remove button label, delimiters and preceding
  660.                ;; space, if any.
  661.                (delete-region (max (point-min)
  662.                            (1- (match-beginning 0)))
  663.                       end)
  664.              ;;
  665.              ;; Remove button delimiters only.
  666.              ;;
  667.              ;; Remove button ending delimiter
  668.              (delete-region start end)
  669.              ;; Remove button starting delimiter
  670.              (delete-region (match-beginning 0)
  671.                     (match-end 0)))))))))
  672.     (if (interactive-p)
  673.     (save-excursion
  674.       (if (search-forward ebut:end nil t) (funcall form)))
  675.       ;; Non-interactive invocation.
  676.       (let ((cur-p))
  677.     (if (and (or (null key-src) (eq key-src buffer-file-name))
  678.          (or (null directory) (eq directory default-directory)))
  679.         (setq cur-p t)
  680.       (set-buffer (find-file-noselect
  681.             (expand-file-name key-src directory))))
  682.     (save-excursion
  683.       (goto-char (point-min))
  684.       (if (re-search-forward (ebut:label-regexp but-key) nil t)
  685.           (progn (funcall form)
  686.              ;; If modified a buffer other than the current one,
  687.              ;; save it.
  688.              (or cur-p (save-buffer)))))))))
  689.  
  690. (defun hui:file-find (file-name)
  691.   "If FILE-NAME is readable, finds it, else signals an error."
  692.   (if (and (stringp file-name) (file-readable-p file-name))
  693.       (find-file file-name)
  694.     (hypb:error "(file-find): \"%s\" does not exist or is not readable."
  695.        file-name)))
  696.  
  697. (defun hui:hbut-term-highlight (start end)
  698.   "For terminals only: Emphasize a button spanning from START to END."
  699.   (save-restriction
  700.     (save-excursion
  701.       (goto-char start)
  702.       (narrow-to-region (point-min) start)
  703.       (sit-for 0)
  704.       (setq inverse-video t)
  705.       (goto-char (point-min))
  706.       (widen)
  707.       (narrow-to-region (point) end)
  708.       (sit-for 0)
  709.       (setq inverse-video nil)
  710.       )))
  711.  
  712. (defun hui:hbut-term-unhighlight (start end)
  713.   "For terminals only: Remove any emphasis from hyper-button at START to END."
  714.   (save-restriction
  715.     (save-excursion
  716.       (goto-char start)
  717.       (narrow-to-region (point-min) start)
  718.       (sit-for 0)
  719.       (setq inverse-video nil))))
  720.  
  721. (defun hui:help-ebut-highlight ()
  722.   "Highlight any explicit buttons in help buffer associated with current buffer."
  723.   (if (fboundp 'hproperty:but-create)
  724.       (save-excursion
  725.     (set-buffer
  726.      (get-buffer (hypb:help-buf-name)))
  727.     (hproperty:but-create))))
  728.  
  729. (defun hui:htype-delete (htype-sym)
  730.   "Deletes HTYPE-SYM from use in current Hyperbole session.
  731. HTYPE-SYM must be redefined for use again."
  732.   (and htype-sym (symbolp htype-sym)
  733.        (let ((type
  734.           (intern (hargs:read-match
  735.                (concat "Delete from " (symbol-name htype-sym) ": ")
  736.                (mapcar 'list (htype:names htype-sym))
  737.                nil t nil htype-sym))))
  738.      (htype:delete type htype-sym))))
  739.  
  740. (defun hui:htype-help (htype-sym &optional no-sort)
  741.   "Displays documentation for types from HTYPE-SYM which match to a regexp.
  742. Optional NO-SORT means display in decreasing priority order (natural order)."
  743.   (and htype-sym (symbolp htype-sym)
  744.        (let* ((tstr (symbol-name htype-sym))
  745.           (tprefix (concat tstr "::"))
  746.           (buf-name (hypb:help-buf-name (capitalize tstr)))
  747.           (temp-buffer-show-hook
  748.            (function
  749.          (lambda (buf)
  750.           (set-buffer buf) (goto-char (point-min))
  751.           (replace-regexp "^" "  ") (goto-char (point-min))
  752.           (replace-string (concat "  " tprefix) "") 
  753.           (goto-char (point-min)) (set-buffer-modified-p nil)
  754.           (display-buffer buf nil))))
  755.           (temp-buffer-show-function temp-buffer-show-hook)
  756.           (names (htype:names htype-sym))
  757.           (term (hargs:read-match
  758.              (concat (capitalize tstr)
  759.                  " to describe (RTN for all): ")
  760.              (mapcar 'list (cons "" names))
  761.              nil t nil htype-sym))
  762.           nm-list
  763.           doc-list)
  764.      (setq nm-list
  765.            (if (string= term "")
  766.            (let ((type-names
  767.                (mapcar (function (lambda (nm) (concat tprefix nm)))
  768.                    names)))
  769.              (if no-sort type-names
  770.                (sort type-names 'string<)))
  771.          (cons (concat tprefix term) nil))
  772.            doc-list (delq nil (mapcar
  773.                     (function
  774.                       (lambda (name)
  775.                     (let ((doc (documentation
  776.                              (intern-soft name))))
  777.                       (if doc (cons name doc)))))
  778.                     nm-list)))
  779.      (with-output-to-temp-buffer buf-name
  780.        (mapcar (function (lambda (nm-doc-cons)
  781.                    (princ (car nm-doc-cons)) (terpri)
  782.                    (princ (cdr nm-doc-cons)) (terpri)))
  783.            doc-list)))))
  784.  
  785. (defun hui:key-dir (but-buf)
  786.   "Returns button key src directory based on BUT-BUF, a buffer."
  787.   (if (bufferp but-buf)
  788.       (let ((file (buffer-file-name but-buf)))
  789.     (if file
  790.         (file-name-directory (hpath:symlink-referent file))
  791.       (cdr (assq 'default-directory (buffer-local-variables but-buf)))))
  792.     (hypb:error "(hui:key-dir): '%s' is not a valid buffer.")))
  793.  
  794. (defun hui:key-src (but-buf)
  795.   "Returns button key src location based on BUT-BUF, a buffer.
  796. This is BUT-BUF when button data is stored in the buffer and the
  797. button's source file name when the button data is stored externally."
  798.   (save-excursion
  799.     (set-buffer but-buf)
  800.     (cond ((hmail:mode-is-p) but-buf)
  801.       ((hpath:symlink-referent (buffer-file-name but-buf)))
  802.       (t but-buf))))
  803.  
  804. (defun hui:link-create (modify but-window lbl-key but-loc but-dir type-and-args)
  805.   "Creates or modifies a new Hyperbole button.
  806. If MODIFY is non-nil, modifies button at point in BUT-WINDOW,
  807. otherwise, prompts for button label and creates a button.
  808. LBL-KEY is internal form of button label.  BUT-LOC is file or buffer
  809. in which to create button.  BUT-DIR is directory of BUT-LOC.
  810. TYPE-AND-ARGS is the action type for the button followed by any arguments it requires."
  811.   (hattr:set 'hbut:current 'loc but-loc)
  812.   (hattr:set 'hbut:current 'dir but-dir)
  813.   (hattr:set 'hbut:current 'actype (intern-soft
  814.                      (concat "actypes::"
  815.                          (symbol-name
  816.                            (car type-and-args)))))
  817.   (hattr:set 'hbut:current 'args (cdr type-and-args))
  818.  
  819.   (select-window but-window)
  820.   (let ((label (ebut:key-to-label lbl-key)))
  821.     (ebut:operate label (if modify label)))
  822.   )
  823.  
  824. (defun hui:link-possible-types ()
  825.   "Returns list of possible link types for a Hyperbole button link to point.
  826. Each list element is a list of the link type and any arguments it requires.
  827.  
  828. The link types considered are fixed.  Defining new link types will not alter
  829. the possible types.  The code must be changed to do that.
  830.  
  831. Referent Context         Possible Link Type Returned
  832. ----------------------------------------------------
  833. Explicit Button          link-to-ebut
  834.   or
  835. Info Node                link-to-Info-node
  836.   or
  837. Mail Reader Msg          link-to-mail
  838.  
  839. Outline Regexp Prefix    link-to-string-match
  840.   or
  841. Directory Name           link-to-directory
  842.   or
  843. File Name                link-to-file
  844.   or
  845. Koutline Cell            link-to-kcell
  846.   or
  847. Buffer attached to File  link-to-file
  848.   or
  849. Buffer without File      link-to-buffer-tmp
  850.  
  851. Elisp Buffer at Start
  852. or End of Sexpression    eval-elisp
  853. "
  854.   (let (val)
  855.     (delq nil
  856.       (list (if (ebut:at-p)
  857.             (list 'link-to-ebut buffer-file-name (ebut:label-p)))
  858.         (cond ((eq major-mode 'Info-mode)
  859.                (let ((hargs:reading-p 'Info-node))
  860.              (list 'link-to-Info-node (hargs:at-p))))
  861.               ((hmail:reader-p)
  862.                (list 'link-to-mail
  863.                  (list (rmail:msg-id-get) buffer-file-name)))
  864.               )
  865.         (cond
  866.          ;; If link is within an outline-regexp prefix, use
  867.          ;; a link-to-string-match.
  868.          ((and (boundp 'outline-regexp)
  869.                (stringp outline-regexp)
  870.                (save-excursion
  871.              (<= (point)
  872.                  (progn
  873.                    (beginning-of-line)
  874.                    (if (looking-at outline-regexp)
  875.                    (match-end 0)
  876.                  0)))))
  877.           (save-excursion
  878.             (end-of-line)
  879.             (let ((heading (buffer-substring
  880.                     (point)
  881.                     (progn (beginning-of-line) (point))))
  882.               (occur 1))
  883.               (while (search-backward heading nil t)
  884.             (setq occur (1+ occur)))
  885.               (list 'link-to-string-match
  886.                 heading occur buffer-file-name))))
  887.          ((let ((hargs:reading-p 'directory))
  888.             (setq val (hargs:at-p t)))
  889.           (list 'link-to-directory val))
  890.          ((let ((hargs:reading-p 'file))
  891.             (setq val (hargs:at-p t)))
  892.           (list 'link-to-file val (point)))
  893.          ((eq major-mode 'kotl-mode)
  894.           (list 'link-to-kcell buffer-file-name (kcell-view:idstamp)))
  895.          (buffer-file-name
  896.           (list 'link-to-file buffer-file-name (point)))
  897.          (t (list 'link-to-buffer-tmp (buffer-name)))
  898.          )
  899.         (and (fboundp 'smart-emacs-lisp-mode-p)
  900.              (smart-emacs-lisp-mode-p)
  901.              (or (= (char-syntax (following-char)) ?\()
  902.              (= (char-syntax (preceding-char)) ?\)))
  903.              (setq val (hargs:sexpression-p))
  904.              (list 'eval-elisp val))
  905.         ))))
  906.  
  907.  
  908. ;;; ************************************************************************
  909. ;;; Private variables
  910. ;;; ************************************************************************
  911.  
  912.  
  913. (defvar hui:ebut-label-prev nil
  914.   "String value of previous button name during an explicit button rename.
  915. At other times, values must be nil.")
  916.  
  917. (provide 'hui)
  918.